home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / seq.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  4KB  |  115 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;   seq.lsp
  6. ;;;;
  7. ;;;;                           sequence routines
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12. (export '(make-sequence concatenate map some every notany notevery))
  13.  
  14. (in-package 'system)
  15.  
  16.  
  17. (proclaim '(optimize (safety 2) (space 3)))
  18.  
  19.  
  20. (defun make-sequence (type size    &key (initial-element nil iesp)
  21.                                 &aux element-type sequence)
  22.   (setq element-type
  23.         (cond ((eq type 'list)
  24.                (return-from make-sequence
  25.                 (if iesp
  26.                     (make-list size :initial-element initial-element)
  27.                     (make-list size))))
  28.               ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
  29.               ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
  30.               ((or (eq type 'simple-vector) (eq type 'vector)) t)
  31.               (t
  32.                (setq type (normalize-type type))
  33.                (when (eq (car type) 'list)
  34.                      (return-from make-sequence
  35.                       (if iesp
  36.                           (make-list size :initial-element initial-element)
  37.                           (make-list size))))
  38.                (unless (or (eq (car type) 'array)
  39.                            (eq (car type) 'simple-array))
  40.                        (error "~S is not a sequence type." type))
  41.                (or (cadr type) t))))
  42.   (setq sequence (si:make-vector element-type size nil nil nil nil nil))
  43.   (when iesp
  44.         (do ((i 0 (1+ i))
  45.              (size size))
  46.             ((>= i size))
  47.           (declare (fixnum i size))
  48.           (setf (elt sequence i) initial-element)))
  49.   sequence)
  50.  
  51.  
  52. (defun concatenate (result-type &rest sequences)
  53.   (do ((x (make-sequence result-type
  54.              (apply #'+ (mapcar #'length sequences))))
  55.        (s sequences (cdr s))
  56.        (i 0))
  57.       ((null s) x)
  58.     (declare (fixnum i))
  59.     (do ((j 0 (1+ j))
  60.          (n (length (car s))))
  61.         ((>= j n))
  62.       (declare (fixnum j n))
  63.       (setf (elt x i) (elt (car s) j))
  64.       (incf i))))
  65.  
  66.  
  67. (defun map (result-type function sequence &rest more-sequences)
  68.   (setq more-sequences (cons sequence more-sequences))
  69.   (let ((l (apply #'min (mapcar #'length more-sequences))))
  70.     (if (null result-type)
  71.         (do ((i 0 (1+ i))
  72.              (l l))
  73.             ((>= i l) nil)
  74.           (declare (fixnum i l))
  75.           (apply function (mapcar #'(lambda (z) (elt z i))
  76.                                   more-sequences)))
  77.         (let ((x (make-sequence result-type l)))
  78.           (do ((i 0 (1+ i))
  79.                (l l))
  80.               ((>= i l) x)
  81.             (declare (fixnum i l))
  82.             (setf (elt x i)
  83.                   (apply function (mapcar #'(lambda (z) (elt z i))
  84.                                           more-sequences))))))))
  85.  
  86.  
  87. (defun some (predicate sequence &rest more-sequences)
  88.   (setq more-sequences (cons sequence more-sequences))
  89.   (do ((i 0 (1+ i))
  90.        (l (apply #'min (mapcar #'length more-sequences))))
  91.       ((>= i l) nil)
  92.     (declare (fixnum i l))
  93.     (let ((that-value
  94.            (apply predicate
  95.                   (mapcar #'(lambda (z) (elt z i)) more-sequences))))
  96.       (when that-value (return that-value)))))
  97.  
  98.  
  99. (defun every (predicate sequence &rest more-sequences)
  100.   (setq more-sequences (cons sequence more-sequences))
  101.   (do ((i 0 (1+ i))
  102.        (l (apply #'min (mapcar #'length more-sequences))))
  103.       ((>= i l) t)
  104.     (declare (fixnum i l))
  105.     (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))
  106.             (return nil))))
  107.  
  108.  
  109. (defun notany (predicate sequence &rest more-sequences)
  110.   (not (apply #'some predicate sequence more-sequences)))
  111.  
  112.  
  113. (defun notevery (predicate sequence &rest more-sequences)
  114.   (not (apply #'every predicate sequence more-sequences)))
  115.